Concursul Compacq, 1996, Problema 2
Problema contrabandistului

  Un contrabandist cutreiera un continent, trecand clandestin frontierele, dar
nu vrea sa treaca de doua ori frontiera dintre aceleasi doua state, de teama
sa nu fie recunoscut. Sa se gaseasca traseul pe care contrabandistul il poate
urma pentru a traversa toate tarile, stiind ca la sfarsit trebuie sa ajunga
inapoi in tara din care a plecat.
  Datele de intrare se citesc din fisierul C.IN, iar datele de iesire vor fi
scrise in fisierul C.OUT.
  Fisierul C.IN are urmatoarea structura, in care statele sunt date prin
siruri de caractere despartite de spatii:

Stat1 Vecin1_1 Vecin1_2... Vecin1_N1
Stat2 Vecin2_1 Vecin2_2... Vecin2_N2
...
StatM VecinM_1 VecinM_2... VecinM_NM

  Fisierul C.OUT va avea structura:
StatS1 StatS2 StatS3... StatSM

De exemplu, se da urmatorul fisier:
X Y Z S T
Y X Z T
Z X S Y
S X T Z
T X Y S
Un posibil rezultat este:
S T Y X Z S
================================

Solutie (Mihai Stroe)
 Problema este un "hibrid" intre problema circuitului hamiltonian si eulerian.
O rezolvare care construieste efectiv circuitul este destul de lenta pe cazuri
mari.
  Construim un graf ale carui noduri reprezinta tarile, iar muchia (i,j)
exista numai daca tarile i si j sunt vecine. Drumul contrabandistului va
evidentia un graf partial eulerian.
  Reformulam problema: se da un graf. Sa se obtina un graf partial eulerian.
  Rezolvarea acestei probleme este mai rapida, deoarece graful este planar
(reprezentand nodurile ca tari, doua muchii nu se intersecteaza) si un graf
planar cu n noduri are maxim 3*n-6 muchii (teorema demonstrata).
  Metoda de rezolvare este backtracking si consta in selectarea muchiilor
eliminate. Pentru a mari viteza programului, se incearca obtinerea unor
solutii rapide pe cazuri particulare.
  Fie M multimea nodurilor de grad impar (dupa eliminari); daca exista un
cuplaj intre nodurile din M, atunci, daca prin eliminarea muchiilor din cuplaj
se pastreaza conexitatea grafului, s-a obtinut un graf conex cu gradele
nodurilor pare, deci un graf eulerian.
  La fiecare apel al procedurii recursive backtracking, se testeaza daca
graful este conex. Daca nu, se paraseste procedura. Se genereaza un cuplaj
si se incearca maximizarea lui (proces euristic; cuplajul nu e realizat in
multimi disjuncte); daca s-a ajuns la solutie, se apeleaza procedura care
genereaza ciclul eulerian. Daca inca nu s-a iesit din procedura, se elimina,
pe rand, muchiile si se apeleaza recursiv procedura.

{$r+}
type se=array[1..100]of set of 1..100;
     ar=array[0..100]of ^se;
var a,b:array[1..100,1..100]of byte;
    nume:array[1..100]of string;
    d,nr:array[1..100]of byte;
    i,j,k,l,m,n:longint;
    fi,fo:text;
    s:string;
    c:char;
    mul,elim:array[1..100]of set of 1..100;
    st:array[1..100,1..2]of byte;
    clase:array[1..100]of set of 1..100;
    cupl:array[1..100]of byte;
    v:array[1..500]of byte;
    luate:set of byte;
    comp:array[1..100]of byte;
    expl:^ar;
    eli,elj:array[0..100]of byte;

procedure readdata;
begin
  assign(fi,'c.in');
  assign(fo,'c.out');
  reset(fi);
  n:=0;
  while not seekeof(fi)do
    begin
      inc(n);
      read(fi,c);
      while (c<>' ')and (not eoln(fi)) do
        begin
          nume[n]:=nume[n]+c;
          read(fi,c);
        end;
      if eoln(fi)then nume[n]:=nume[n]+c;
      readln(fi);
    end;
  close(fi);
  reset(fi);
  for i:=1 to n do
      begin
        read(fi,c);
        while (c<>' ') and (not eoln(fi)) do
          read(fi,c);
        while not seekeoln(fi)do
          begin
            s:='';
            read(fi,c);
            while (c<>' ') and (not eoln(fi)) do
              begin
                s:=s+c;
                read(fi,c);
              end;
            if(c<>' ')and(eoln(fi)) then s:=s+c;
            for j:=1 to n do
                if s=nume[j] then
                   begin
                     inc(d[i]);
                     a[i,d[i]]:=j;
                     mul[i]:=mul[i]+[j];
                   end;
          end;
        readln(fi);
      end;
  rewrite(fo);
end;

procedure calcul_b;
var i,j:longint;
begin
  for i:=1 to n do
      d[i]:=0;
  for i:=1 to n do
      for j:=1 to nr[i] do
          if not(a[i,j] in elim[i]) then
             begin
               inc(d[i]);
               b[i,d[i]]:=a[i,j];
             end;
end;

procedure eulerian;
var i,j,suma,k:longint;
begin
  calcul_b;
  suma:=0;
  for i:=1 to n do
      if d[i]mod 2=1 then exit;
  for i:=1 to n do suma:=suma+d[i];
  suma:=suma div 2;
  m:=1;
  v[1]:=1;
  while m<=suma do
    begin
      k:=m;
      while d[v[k]]=0 do dec(k);
      for i:=m+1 downto k+1 do
         v[i+1]:=v[i];
      inc(m);
      v[k+1]:=b[v[k],1];
      b[v[k],1]:=b[v[k],d[v[k]]];
      dec(d[v[k]]);
      b[v[k],d[v[k]]+1]:=0;
      i:=1;
      while b[v[k+1],i]<>v[k] do inc(i);
      b[v[k+1],i]:=b[v[k+1],d[v[k+1]]];
      dec(d[v[k+1]]);
      b[v[k+1],d[v[k+1]]+1]:=0;
    end;
  for i:=1 to m-1 do
      write(fo,nume[v[i]],' ');
  writeln(fo,nume[v[m]]);
  close(fo);
  halt;
end;

function conex:boolean;
var i,j,m,ii,jj,k,st,en:byte;
begin
  conex:=true;
  for ii:=1 to n do
      for jj:=1 to nr[ii] do
          if a[ii,jj]>ii then
          if a[ii,jj]in mul[ii] then
          if not(a[ii,jj] in elim[ii])then
             begin
               elim[ii]:=elim[ii]+[a[ii,jj]];
               elim[a[ii,jj]]:=elim[a[ii,jj]]+[ii];
               fillchar(comp,sizeof(comp),0);
               st:=1;en:=1;comp[1]:=1;luate:=[1];
               while (st<=en)and(en<n) do
                 begin
                   for i:=1 to nr[comp[st]] do
                       if not(a[comp[st],i] in luate) then
                       if (not(a[comp[st],i] in elim[comp[st]])) then
                          begin
                            inc(en);
                            comp[en]:=a[comp[st],i];
                            luate:=luate+[comp[en]];
                          end;
                   inc(st);
                 end;
               if luate<>[1..n] then
                  begin
                    conex:=false;
                    elim[ii]:=elim[ii]-[a[ii,jj]];
                    elim[a[ii,jj]]:=elim[a[ii,jj]]-[ii];
                    exit;
                  end;
               elim[ii]:=elim[ii]-[a[ii,jj]];
               elim[a[ii,jj]]:=elim[a[ii,jj]]-[ii];
               exit;
             end;
end;

procedure cuplaj;
var i,j,m,ii,jj:byte;
begin
  for i:=1 to n do
      cupl[i]:=0;
  m:=1;
  while m=1 do
    begin
      m:=0;
      for i:=1 to n do
          if d[i] mod 2=1 then
             if cupl[i]=0 then
                for j:=1 to nr[i] do
                    if d[a[i,j]]mod 2=1 then
                       if cupl[a[i,j]]=0 then
                          if not(a[i,j] in elim[i])then
                             if m=0 then
                             begin
                               cupl[i]:=a[i,j];
                               cupl[a[i,j]]:=i;
                               m:=1;
                             end;
      for i:=1 to n do
          if cupl[i]<>0 then
             for ii:=1 to nr[i] do
                 if cupl[a[i,ii]]=0 then
                 if d[a[i,ii]] mod 2=1 then
                    if not(a[i,ii] in elim[i]) then
                       if a[i,ii]<>cupl[i] then
             for jj:=1 to nr[cupl[i]] do
                 if m=0 then
                 if cupl[a[cupl[i],jj]]=0 then
                 if d[a[cupl[i],jj]] mod 2=1 then
                    if not(a[cupl[i],jj] in elim[j]) then
                       if a[cupl[i],jj]<>i then
                          if m=0 then
                          if a[i,ii]<>a[cupl[i],jj] then
                          begin
                            cupl[cupl[i]]:=a[cupl[i],jj];
                            cupl[cupl[cupl[i]]]:=cupl[i];
                            cupl[i]:=a[i,ii];
                            cupl[a[i,ii]]:=i;
                            m:=1;
                          end;
    end;
  m:=0;
  for i:=1 to n do
      if d[i] mod 2=1 then
      if cupl[i]=0 then m:=1;
  if m=1 then exit
     else
     begin
       for i:=1 to n do
           elim[i]:=elim[i]+[cupl[i]];
       if conex then
          eulerian
          else
          for i:=1 to n do
              elim[i]:=elim[i]-[cupl[i]];
     end;
end;

procedure rec(k:byte);
var i,j,m:byte;
begin
  if not conex then exit;

  expl^[k]:=expl^[k-1];


  m:=0;
  for i:=1 to n do
      if d[i] mod 2=1 then m:=1;
  if m=0 then
  eulerian;
  cuplaj;
  for i:=1 to n do
      if d[i]>2 then
      if i>=eli[k-1] then
      for j:=1 to nr[i] do
          if not (a[i,j] in elim[i])then
             if d[a[i,j]]>2 then
                if (i>eli[k-1])or((i=eli[k-1])and(a[i,j]>elj[k-1])) then
                if a[i,j]>i then
                if (d[i] mod 2=1)or(d[a[i,j]] mod 2=1)then
                   begin
                     elim[i]:=elim[i]+[a[i,j]];
                     elim[a[i,j]]:=elim[a[i,j]]+[i];
                     dec(d[i]);
                     dec(d[a[i,j]]);
                     eli[k]:=i;
                     elj[k]:=a[i,j];
                     rec(k+1);
                     elim[i]:=elim[i]-[a[i,j]];
                     elim[a[i,j]]:=elim[a[i,j]]-[i];
                     inc(d[i]);
                     inc(d[a[i,j]]);
                   end;
  eli[k]:=0;
  elj[k]:=0;
end;

procedure solve;
begin
   new(expl);
   for i:=1 to n do
       new(expl^[i]);
   for i:=1 to n do
       for j:=1 to n do
           expl^[i]^[j]:=[];
   nr:=d;
   rewrite(fo);
   k:=0;
   for i:=1 to n do
       for j:=1 to d[i] do
           if not(i in mul[a[i,j]]) then
           k:=1;
   if k=1 then
      begin
        writeln(fo,'Eroarea 1: O tara e vecina alteia, dar cealalta nu e vecina ei.');
        close(fo);
        halt;
      end;
   m:=0;
   for i:=1 to n do
       if d[i]=0 then
          begin
            writeln(fo,'O tara e izolata. Nu exista solutie.');
            close(fo);
            halt;
          end
          else
       if d[i]=1 then
          begin
            writeln(fo,'O tara are un singur vecin. Nu exista solutie.');
            writeln(fo,'Daca se pleaca din ea, nu este posibila intoarcerea.');
            writeln(fo,'Daca nu se pleaca din ea si se poate intra in ea, nu se poate iesi.');
            close(fo);
            halt;
          end
          else
          m:=m+d[i];
   if m div 2>3*n-6 then
      begin
        writeln(fo,'Nu exista harta prezentata.');
        writeln(fo,'Orice harta corecta poate fi reprezentata sub forma unui graf planar.');
        writeln(fo,'Un graf planar cu n noduri are maxim 3*n-6 muchii.');
        writeln(fo,'Graful asociat datelor de intrare are mai multe muchii, deci nu este planar.');
        close(fo);
        halt;
      end;
  rec(1);
  writeln(fo,'Nu exista solutie.');
  close(fo);
end;

begin
  readdata;
  solve;
end.
-----------------------------
